home *** CD-ROM | disk | FTP | other *** search
/ SPACE 1 / SPACE - Library 1 - Volume 1.iso / apps / 375 / cal_cnt / cal_cnt.lst next >
File List  |  1988-11-17  |  14KB  |  421 lines
  1. ' ############################################################################
  2. ' ############################################################################
  3. ' #############################  CALORIE COUNTER  ############################
  4. ' #######################  BY RON & KATHY SCHAEFER MDs  ######################
  5. ' #############################  Published by     ############################
  6. ' #############################  ST Log   1/89    ############################
  7. ' ############################################################################
  8. ' ############################################################################
  9. If Xbios(4)=0 Then
  10.   Alert 3,"SORRY WORKS IN HIGH & MEDIUM|RESOLUTION ONLY",1,"BYE",Dummy
  11.   Edit
  12. Endif
  13. Rez%=Xbios(4)             ! Check resolution 0=low 1=med 2=high
  14. If Xbios(4)=2 Then
  15.   Tf%=7                 ! Correction faction factor for text size
  16. Endif
  17. Dim Spalette%(16,3)
  18. @Save_pal               ! Save current pallet
  19. @Setcolors              ! Set program screen colors
  20. @Introscreen            ! Do title screen
  21. Do
  22.   At$="Calorie Counter|By Ron & Kathy Schaefer M.D.s|(C) 1988 Schaefer SuperGraphics|"
  23.   At$=At$+"Published by ST Log"
  24.   Alert 0,At$,1,"Count|Help|Quit",Dummy
  25.   Exit If Dummy=3
  26.   If Dummy=1 Then
  27.     @Calcount
  28.     Cls
  29.   Endif
  30.   If Dummy=2 Then
  31.     @Help
  32.   Endif
  33. Loop
  34. @Restorepal           ! Restore original palet at end of prgram
  35. Edit
  36. ' ----------------------- HELP SUBROUTINE --------------------------------
  37. Procedure Help
  38.   Titlew 1,"  HELP  "
  39.   Deftext 1,0,0,6+Tf%
  40.   Openw 1            ! if using 3.0 use this instead OPENW 1,0,19
  41.   Fullw 1
  42.   Clearw 1
  43.   Print At(1,2);
  44.   Print "  To use the Calorie Counter just load in the expandable data base"
  45.   Print "  of food items called CALORIES.DAT, this is done automatically if"
  46.   Print "  the file is in the same directory as the program CAL_CNT.PRG"
  47.   Print
  48.   Print "  Now enter in the number of calories that you want to plan your"
  49.   Print "  meal or day for.  This will serve as a Goal diet."
  50.   Print
  51.   Print "  Once the food items have been loaded just click on the items"
  52.   Print "  that you want added up.  Click with the left button to add,"
  53.   Print "  and with the right button to subtract an item.  As you plan"
  54.   Print "  your menu, try and approximate the Goal or Ideal diet."
  55.   Print
  56.   Print "  You can print out a list of the selected foods to take with"
  57.   Print "  you to store by clicking on LIST at the bottom of the screen."
  58.   Print
  59.   Print "          Ideal American Diet:      % of total calories"
  60.   Print "          ============================================="
  61.   Print "                   Protein            12%"
  62.   Print "                   Fats               30%"
  63.   Print "                   Carbohydrates      58%"
  64.   Print "                                            hit return to continue";
  65.   Void=Inp(2)
  66.   Closew 1
  67. Return
  68. ' ---------------------- MAIN CALORIE COUNT SUBROUTINE ----------------
  69. Procedure Calcount
  70.   K=0
  71.   If Not Openfile!        ! If the file has not been opend do so
  72.     Path$=Dir$(0)
  73.     Filename$=Path$+"\CALORIE.DAT"
  74.     If Not Exist(Filename$) Then
  75.       Fileselect "*.DAT","CALORIE.DAT",Filename$
  76.     Endif
  77.   Endif
  78.   If Filename$<>"" Then
  79.     Titlew 1," Calorie Counter and Menu Planner "
  80.     Openw 1            ! if using 3.0 use this instead OPENW 1,0,19
  81.     Fullw 1
  82.     Graphmode 1
  83.     Clearw 1
  84.     Deftext 1,0
  85.     If Not Openfile! Then
  86.       Print
  87.       Print
  88.       Print "                  Opening the file ";Filename$
  89.       Print "                  Reading in calorie data on item:";
  90.       Color 1
  91.       Box 139,13*Rez%,467,35*Rez%
  92.       Box 136,11*Rez%,470,37*Rez%
  93.       Open "I",#1,Filename$
  94.       Openfile!=True
  95.       Input #1,T%       ! Read in number of food items and DIM arrays
  96.       Dim N$(T%),Cals(T%),Fats(T%),Carbos(T%),Prots(T%),Quant(T%)
  97.       Do
  98.         Inc Nt%
  99.         Print At(54,4);Nt%
  100.         Input #1,N$(Nt%),Cals(Nt%),Prots(Nt%),Fats(Nt%),Carbos(Nt%)
  101.         Exit If Eof(#1)
  102.       Loop
  103.       Close #1
  104.     Else
  105.       For N%=1 To T%
  106.         Quant(N%)=0
  107.       Next N%
  108.       Caltotal=0
  109.       Prottotal=0
  110.       Carbototal=0
  111.       Fattotal=0
  112.     Endif
  113.     Print At(21,10);"Enter the number of calories to be"
  114.     Print At(21,11);"your goal: ";
  115.     Color 1
  116.     Box 154,68*Rez%,445,92*Rez%
  117.     Box 151,66*Rez%,448,94*Rez%
  118.     Input "",Gcaltotal
  119.     Clearw 1
  120.     Defmouse 6
  121.     Deftext 2
  122.     @Initmenuplaner
  123.     ' ******* main loop *********
  124.     Do
  125.       If Mx>475 And My>157*Rez% And K=1 Then
  126.         @Do_sound_1(5,4)
  127.       Endif
  128.       Exit If Mx>475 And My>157*Rez% And K=1
  129.       Showm
  130.       Mouse Mx,My,K
  131.       If K>0 Then
  132.         If My>35*Rez% And My<153*Rez% Then
  133.           @Do_sound_2(9,7)
  134.         Endif
  135.         If My>159*Rez% Then
  136.           @Do_sound_1(3,4)
  137.         Endif
  138.         If My>35*Rez% And My<153*Rez% Then    ! Find which item mouse is over
  139.           If Rez%=1 Then
  140.             L%=Int((My-35)/8)+1
  141.           Else
  142.             L%=Int(((My-35)/8)/Rez%)-1
  143.           Endif
  144.           If K=1 And L%+F%<=T% Then
  145.             Inc Quant(L%+F%)                   ! Add food item
  146.             Add Caltotal,Cals(L%+F%)
  147.             Add Fattotal,Fats(L%+F%)
  148.             Add Prottotal,Prots(L%+F%)
  149.             Add Carbototal,Carbos(L%+F%)
  150.           Endif
  151.           If K=2 And L%+F%<=T% Then
  152.             Dec Quant(L%+F%)                  ! Subtract food item
  153.             If Quant(L%+F%)<0 Then
  154.               Quant(L%+F%)=0
  155.             Else
  156.               Sub Caltotal,Cals(L%+F%)
  157.               Sub Fattotal,Fats(L%+F%)
  158.               Sub Prottotal,Prots(L%+F%)
  159.               Sub Carbototal,Carbos(L%+F%)
  160.             Endif
  161.           Endif
  162.           If L%+F%<=T% Then
  163.             If Quant(L%+F%)=0 Then
  164.               Deftext 1,0
  165.             Else
  166.               Deftext 2,1   ! If the quantity is >0 highlight that item
  167.             Endif
  168.             Print At(2,4+L%);N$(L%+F%);"  "
  169.             Print At(30,4+L%);Cals(L%+F%);"  "
  170.             Print At(40,4+L%);Fats(L%+F%);"  "
  171.             Print At(50,4+L%);Carbos(L%+F%);"  "
  172.             Print At(60,4+L%);Prots(L%+F%);"  "
  173.             Print At(70,4+L%);Quant(L%+F%);"  "
  174.           Endif
  175.           Deftext 3,0
  176.           Print At(2,3);"TOTAL";
  177.           Print At(30,3);Caltotal;"  "
  178.           Print At(40,3);Int(Fattotal);"  "
  179.           Print At(50,3);Int(Carbototal);"  "
  180.           Print At(60,3);Int(Prottotal);"  "
  181.           Print At(66,3);"Quantity"
  182.           Deftext 1
  183.         Endif
  184.         If Mx<154 And My>157*Rez% Then
  185.           Add F%,15
  186.           If F%>T% Then
  187.             Sub F%,15
  188.           Endif
  189.           For N%=1 To 15
  190.             If (N%+F%)<=T% Then
  191.               If Quant(N%+F%)=0 Then
  192.                 Deftext 1,0
  193.               Else
  194.                 Deftext 2,1   ! If the quantity is >0 highlight that item
  195.               Endif
  196.               Print At(2,4+N%);N$(N%+F%);"  "
  197.               Print At(30,4+N%);Cals(N%+F%);"  "
  198.               Print At(40,4+N%);Fats(N%+F%);"  "
  199.               Print At(50,4+N%);Carbos(N%+F%);"  "
  200.               Print At(60,4+N%);Prots(N%+F%);"  "
  201.               Print At(70,4+N%);Quant(N%+F%);"  "
  202.             Else
  203.               Print Space$(72)
  204.             Endif
  205.           Next N%
  206.           Deftext ,0
  207.         Endif
  208.         If Mx>154 And Mx<321 And My>157*Rez% Then
  209.           Add F%,-15
  210.           If F%<0 Then
  211.             F%=0
  212.           Endif
  213.           For N%=1 To 15
  214.             If Quant(N%+F%)>0 Then
  215.               Deftext 2,1   ! If the quantity is >0 highlight that item
  216.             Else
  217.               Deftext 1,0
  218.             Endif
  219.             Print At(2,4+N%);N$(N%+F%);"  "
  220.             Print At(30,4+N%);Cals(N%+F%);"  "
  221.             Print At(40,4+N%);Fats(N%+F%);"  "
  222.             Print At(50,4+N%);Carbos(N%+F%);"  "
  223.             Print At(60,4+N%);Prots(N%+F%);"  "
  224.             Print At(70,4+N%);Quant(N%+F%);"  "
  225.           Next N%
  226.           Deftext ,0
  227.         Endif
  228.         If Mx>321 And Mx<475 And My>157*Rez% Then         ! LIST routine
  229.           Clearw 1
  230.           At$="Where do you want the menu|list to be printed?"
  231.           Alert 2,At$,1," Screen | Printer ",Pr
  232.           @Do_sound_2(4,4)
  233.           Defmouse 6
  234.           If Pr=1 Then
  235.             Deftext 1
  236.             Tx$="  Menu Listing           Calories   Fat      Carbo    "
  237.             Print At(2,2);Tx$+"Protein   Quantity"
  238.             Print At(1,3);String$(72,"=")
  239.             Ln%=0
  240.             For N%=1 To T%
  241.               If Quant(N%)>0 Then
  242.                 Print At(2,4+Ln%);N$(N%);"  "
  243.                 Print At(30,4+Ln%);Cals(N%);"  "
  244.                 Print At(40,4+Ln%);Fats(N%);"  "
  245.                 Print At(50,4+Ln%);Carbos(N%);"  "
  246.                 Print At(60,4+Ln%);Prots(N%);"  "
  247.                 Print At(70,4+Ln%);Quant(N%);"  "
  248.                 ' Print At(2,3+Ln%);N$(N%),Cals(N%),Quant(N%)
  249.                 Inc Ln%
  250.                 If Ln%>15 Then
  251.                   Ln%=0
  252.                   Print At(55,21);"Click to continue."
  253.                   Do
  254.                     K=Mousek
  255.                     Exit If K>0
  256.                   Loop
  257.                   Clearw 1
  258.                   Tx$="  Menu Listing           Calories   Fat      Carbo    "
  259.                   Print At(2,2);Tx$;"Protein   Quantity"
  260.                   Print At(1,3);String$(72,"=")
  261.                 Endif
  262.               Endif
  263.             Next N%
  264.             Print String$(72,"=")
  265.             Deftext 3
  266.             Print At(2,5+Ln%);"TOTAL";
  267.             Print At(30,5+Ln%);Caltotal;"  "
  268.             Print At(40,5+Ln%);Int(Fattotal);"  "
  269.             Print At(50,5+Ln%);Int(Carbototal);"  "
  270.             Print At(60,5+Ln%);Int(Prottotal);"  "
  271.             Deftext 2
  272.             Print At(55,21);"Click to continue."
  273.             Deftext 1
  274.             Do
  275.               K=Mousek
  276.               Exit If K>0
  277.             Loop
  278.             Clearw 1
  279.           Else        ! Print out list of items on the printer
  280.             Sd=10
  281.             Tx$="  Menu Listing          Calories   Grams     Grams     "
  282.             Lprint Tx$;"Grams    Quantity"
  283.             Lprint Space$(35);"Fat       Carbo     Protein"
  284.             Lprint String$(72,"=")
  285.             For N%=1 To T%
  286.               If Quant(N%)>0 Then
  287.                 Lprint N$(N%);Space$(27-Len(N$(N%)));
  288.                 Lprint Cals(N%);Space$(Sd-Len(Str$(Cals(N%))));
  289.                 Lprint Fats(N%);Space$(Sd-Len(Str$(Fats(N%))));
  290.                 Lprint Carbos(N%);Space$(Sd-Len(Str$(Carbos(N%))));
  291.                 Lprint Prots(N%);Space$(Sd-Len(Str$(Prots(N%))));
  292.                 Lprint Quant(N%)
  293.               Endif
  294.             Next N%
  295.             Lprint String$(72,"=")
  296.             Lprint "  TOTAL";Space$(20);
  297.             Lprint Caltotal;Space$(Sd-Len(Str$(Caltotal)));
  298.             Lprint Fattotal;Space$(Sd-Len(Str$(Fattotal)));
  299.             Lprint Carbototal;Space$(Sd-Len(Str$(Carbototal)));
  300.             Lprint Prottotal;Space$(Sd-Len(Str$(Prottotal)))
  301.           Endif
  302.           Ln%=0
  303.           F%=0
  304.           @Initmenuplaner
  305.         Endif
  306.       Endif
  307.     Loop
  308.     Clearw 1
  309.     Closew 1
  310.     Deftext 1
  311.   Endif
  312. Return
  313. ' ################# set up and draw first screen for menu planner #########
  314. Procedure Initmenuplaner
  315.   Deftext 2
  316.   Print "                            Calories   Fat      Carbo    Protein"
  317.   Deftext 3
  318.   Print At(2,2);"GOAL";
  319.   Print At(30,2);Gcaltotal
  320.   Print At(40,2);Int(Gcaltotal*0.3/9)
  321.   Print At(50,2);Int(Gcaltotal*0.58/4)
  322.   Print At(60,2);Int(Gcaltotal*0.12/4)
  323.   Print At(2,3);"TOTAL";
  324.   Print At(30,3);Caltotal
  325.   Print At(40,3);Fattotal
  326.   Print At(50,3);Carbototal
  327.   Print At(60,3);Prottotal
  328.   Print At(66,3);"Quantity"
  329.   Deftext 1
  330.   Print String$(72,"=")
  331.   Print At(1,20);String$(72,"=")
  332.   Deftext 3
  333.   Print At(7,21);"NEXT PAGE"
  334.   Print At(27,21);"LAST PAGE              LIST              QUIT"
  335.   For N%=1 To 15
  336.     If Quant(N%+F%)>0 Then
  337.       Deftext 2,1
  338.     Else
  339.       Deftext 1,0
  340.     Endif
  341.     Print At(2,4+N%);N$(N%+F%);"  "
  342.     Print At(30,4+N%);Cals(N%+F%);"  "
  343.     Print At(40,4+N%);Fats(N%+F%);"  "
  344.     Print At(50,4+N%);Carbos(N%+F%);"  "
  345.     Print At(60,4+N%);Prots(N%+F%);"  "
  346.     Print At(70,4+N%);Quant(N%+F%);"  "
  347.   Next N%
  348.   Color 0
  349. Return
  350. ' --------------------- CLICKING SOUND SUBROUINTES ------------
  351. Procedure Do_sound_1(Snd,Snd1)
  352.   Sound 1,12,Snd,Snd1
  353.   Wave 1,1,9,6000
  354. Return
  355. Procedure Do_sound_2(Snd,Snd1)
  356.   Sound 1,12,Snd,Snd1
  357.   Wave 1,1,8,512,5
  358.   Wave 0,0
  359. Return
  360. Procedure Do_sound_3(Snd,Snd1,Per,Dur)
  361.   Sound 1,2,Snd,Snd1
  362.   Wave 1,1,9,Per,Dur
  363. Return
  364. ' --------------------------- SET SCREEN COLORS -------------------
  365. Procedure Setcolors
  366.   Setcolor 2,0,7,7
  367.   Setcolor 0,0,0,0
  368.   Setcolor 3,7,7,7
  369.   Setcolor 1,7,0,2
  370. Return
  371. ' ------------- SAVE ORIGINAL COLOR PALETTE -----------------------
  372. Procedure Save_pal
  373.   For Z%=0 To 15
  374.     Dpoke Contrl,26
  375.     Dpoke Contrl+2,0
  376.     Dpoke Contrl+6,2
  377.     Dpoke Intin,Z%
  378.     Dpoke Intin+2,0
  379.     Vdisys
  380.     Spalette%(Z%,0)=Dpeek(Intout+2)
  381.     Spalette%(Z%,1)=Dpeek(Intout+4)
  382.     Spalette%(Z%,2)=Dpeek(Intout+6)
  383.   Next Z%
  384. Return
  385. Procedure Restorepal
  386.   ' --------------------- RESTORES PALLET -------------------
  387.   For Z%=0 To 15
  388.     Dpoke Contrl,14
  389.     Dpoke Contrl+2,0
  390.     Dpoke Contrl+6,4
  391.     Dpoke Intin,Z%
  392.     Dpoke Intin+2,Spalette%(Z%,0)
  393.     Dpoke Intin+4,Spalette%(Z%,1)
  394.     Dpoke Intin+6,Spalette%(Z%,2)
  395.     Vdisys
  396.   Next Z%
  397. Return
  398. ' ------------------------ DO INTRO TITLE SCREEN ---------------------
  399. Procedure Introscreen
  400.   For Zz=1 To 12
  401.     Deftext 3,0,0,Zz
  402.     @Do_sound_1(1,Zz/2)
  403.     Text 160,30*Rez%,"Calorie Counter"
  404.     Pause 3
  405.   Next Zz
  406.   For Zz=1 To 12
  407.     Deftext 2,0,0,Zz
  408.     @Do_sound_1(1,Zz/2)
  409.     Text 80,48*Rez%,"by Ron & Kathy Schaefer M.D.s"
  410.     Pause 3
  411.   Next Zz
  412.   For Zz=1 To 12
  413.     Deftext 1,0,0,Zz
  414.     @Do_sound_1(1,Zz/2)
  415.     Text 125,66*Rez%,"Brought to You by ST Log"
  416.     Pause 3
  417.   Next Zz
  418.   Deftext 1,0,0,6+Tf%
  419.   Pause 10
  420. Return
  421.